module readmge

        implicit none

!       Records of source data:

!!      Defines a line of MPSGE source code.

        type line
          character (len=2048) :: text		!! Input records are limited to 2048 characters
          integer :: lineno			!! Line number in the input file
	  type (record), pointer :: record	!! Record to which this line belongs
          type (line), pointer :: next		!! Pointer to the next line
        end type line

!!      Defines a list of input lines as they have been read from the input file.

        type linelist
          type (line), pointer :: line
          type (linelist), pointer :: next
        end type linelist

!!      Elements of the symbol table include various MPSGE variables (commodity
!!      prices, sectoral activity level, consumer incomes and auxiliary variables).
!!      The symbol table also includes sets and parameters which are encountered
!!      in the input file.  This list is maintained to provide some context checking
!!      on input.

        type symbol
!		Note by KP. a real constant (eg "2.1" as in "q:2.1") is not added to the symbol table.
!		See the use of the logical function "numeric" in Tom's code.
          character (len=31) :: name		!! Symbol identifier
          character (len=9) :: type		!! One of set, parameter, sector, commodity, consumer, auxiliary
          type (linelist), pointer :: lines     !! Points to lines in which this symbol appears

!	Note by KP. ** WARNING. arg may be only set for sector, commodity and consumer. 
	  type (domain), pointer :: arg		!! Points to the arguments (when relevant)  ! added by KP
	  character (len=255) :: labelinfo      !! labelling info (relevant for sector, commodity, consumer) ! added by KP

          type (symbol), pointer :: next        !! Points to next symbol in the global list
          integer :: dim			!! Dimension of the symbol (undefined=-1,scalar=0, vector=1, etc.)
        end type symbol

!!      A domain is simply a list of sets.  This list may include quoted singletons as well as
!!      references to GAMS sets.  Each element of the set is represented by a pointer to the
!!      set in the symbol table

        type domain
          type (symbol), pointer :: s           !! Pointer to this set in the symbol table
          type (domain), pointer :: next        !! Pointer to the next set in this domain (unassociated if no more dimensions)
          integer :: dim			!! Dimension of this domain
        end type domain

!!      An MPSGE input file consists of a series of records.  Each record is composed of
!!      one or more fields.  An input field consist of a label and some field text.

!!      A field in an MPSGE model consists of two primary components: the label and
!!      the field data.  The field data in turn consists of the identifier,
!!      the identifier argument, the spanning sets and the condition clause.

        type field
          character (len=255)   :: label	!! Verbatim text of leading label
          character (len=255)   :: data		!! Verbatim text of following field 
          character (len=255)   :: identtext	!! Identifier text (data excluding domain and condition)
          character (len=255)   :: argtext	!! Substring text of the identitier argument domain if present
          character (len=255)   :: spantext	!! Substring text of the spanning domain if present (# notation)
          character (len=255)   :: condtext	!! Substring text of the conditional clause if present
          type (symbol), pointer :: ident       !! Pointer to field idenfier if the field is readable. 
						!! Fields beginning with "(" are skipped.
          type (domain), pointer :: arg		!! Pointer to argument domain if it is readable
          type (domain), pointer :: span        !! Points to span domain if it is present
	  type (domain), pointer :: cond	!! Points to domain of the condition if it is present
          type (line),   pointer :: line        !! Points to source line
          type (field),  pointer :: next	!! Pointer to next field in the data file.
						!! The final field in a datafile is unassociated.
        end type field

!!      This type describes a _record_ in an MPSGE function, possibly spanning multiple lines
!!      if there are continuations (lines "+" in the first column)

        type record
          type (field), pointer  :: firstfield  !! Points to the first field in this record
          type (line), pointer   :: line        !! Points to the input line where this record begins.
          integer                :: nfield      !! Counts the number of fields in this record
          type (record), pointer :: next        
        end type record

!!      A tax coefficient on a production input or output consists of:
!!      - A tax revenue agent (identified in an A: field)
!!      - An ad-valorem tax rate defined by one of the following:
!!        - A T: field representing a fixed and exogenous tax rate
!!        - A N:/M: field pair representing an endogenous tax.
!!      The tax coefficient consists only of pointers to fields in the input file.  Note that 
!!      the A: field may be on a record which appears prior to the tax rate field.
!!      With endogenous taxes, the N: field defines an auxiliary variable which controls the tax
!!      and the M: field defines a multiplier on the tax rate.

        type taxlist

!!      Pointer to A: field which identifes agent who collects this tax revenue:

              type (field), pointer :: a

!!      Pointer to T: field which defines an exogenous ad-valorem tax rate:

              type (field), pointer :: t

!!      Pointer to N: field indicating the auxiliary variable which determines the
!!      ad-valorem tax rate.  For a given tax entry, either T: or N: will be
!!      used, but not both:

              type (field), pointer :: n

!!      Pointer to an M: field defining the multiplier which is to be applied on 
!!      the previously listed endogenous tax.  An M: field must follow immediately
!!      after an N: field.

              type (field), pointer :: m

!!      Next tax applied on the same production input or output.  This is unassociated
!!      if there are no more applicable taxes:

              type (taxlist), pointer :: next
        end type taxlist

        type endowment
                type (field), pointer    :: f           !! Pointer to the E: field
                type (field), pointer    :: q           !! Pointer to the Q: field
		type (field), pointer    :: r		!! Pointer to the R: field
                type (domain), pointer   :: d           !! Pointer to the domain of the endowment
                type (domain), pointer   :: sd          !! Pointer to the subdomain of the endowment
		integer :: index
        end type endowment

!!	List of endowment records

	type endowmentlist
		type (endowment), pointer     :: e	
		type (endowmentlist), pointer :: next
	end type endowmentlist


!!      Nest type characterizes a CES nest in a cost function.

        type nest
                character (len=255) :: ident		!! Identifier text for this nest 
                character (len=255) :: parentid		!! Identifier text for the parent nest
                character (len=255) :: value            !! Text field of the elasticity value
                logical :: output                       !! Logical flag identifies type of nest (output or input)
                type (field), pointer :: f              !! Pointer to the input field which defines the nest
                type (nest), pointer :: parent          !! Pointer to parent nest
                type (nestlist), pointer :: nlist       !! Pointer to parent nestlist entry
                type (nestlist), pointer :: subnests    !! Pointer to a list of constituent nests
                type (nest), pointer :: next            !! Pointer to next nest in current function
                integer :: index                        !! Integer index associated with this nest
		character (len=255) :: pname, qname	!! Identifier for price and quantity names for this nest
		integer :: level			!! Level in the nesting structure (top level = 0)
		logical :: assigned			!! Flag that all the logic for this nest has been written
	end type nest

!!      Linked list of nests used to represent the nested CES substitution structure:

        type nestlist
                type (nest), pointer :: n               !! Pointer to a nest in this list
                type (nestlist), pointer :: next        !! Pointer to next element of the list
        end type nestlist

!! An MPSGE production or demand function

        type function           
          type (record), pointer :: firstrecord !! Pointer to first input record in this function
          integer               :: nrecord      !! Count of number of records in this function
          integer               :: nfield       !! Count of number of fields in this function
          type (nest), pointer  :: inputs       !! Points to the top level input nest    
          type (nest), pointer  :: outputs      !! Points to the top level output nest    
	  type (field), pointer :: demand		!! Points to the demand field
	  type (endowmentlist), pointer :: endowments	!! Points to the endowments declared in this $demand block
          type (function), pointer :: next      !! Pointer in linked list of all functions
        end type function

        type (line), pointer     :: inputfile   !! Pointer to first line in the linked list of input file lines
        type (function), pointer :: functionlist !! Pointer to the first function in linked list
        type (symbol), pointer   :: idlist      !! Pointer to the first symbol
        type (symbol), pointer   :: idlast      !! Pointer to the last symbol

        character (len=32) :: modelname

        integer :: nfun               !! Number of functions in the MPSGE file
        integer, parameter :: iomps=10  !! Unit number of the MPSGE file
        integer, parameter :: iogms=11  !! Unit number of the resulting GAMS file
	integer, parameter :: iomge=12	!! Unit number of the resulting MGE file
        character (len=255) :: NewMGEFileName

! These set false by KP [12/06/04] to check what output comes when this is run in "normal" mode
	logical :: splitlog=.true.	!! Flag for log output of field parsing operation
	logical :: log=.true.		!! Flag for general log output
        logical :: readvars             !! Flag for current input of declaration records


! Note by KP. Use this when writing a single string to terminal
	character (len=6), parameter :: fmt = '(1x,a)'
! KP Use FileFmt when writing a single string to a file
	character (len=3), parameter :: FileFmt = '(a)'
! Note by KP. Use this when writing up to 4 strings to terminal
	character (len=7), parameter :: fmt4 = '(1x,4a)'

contains

!!      Master routine to read an MPSGE input file:
!!        - Open the file
!!        - Read one line at a time into a linked list for listing.
!!        - Locate functions and set up pointers to the constituent records.
!!        - Parse records into fields.
!!
!!	None of the logical structure of the underlying economic model is
!!	formulated at this stage.

        subroutine readmps
        integer :: lineno
	type (line), pointer :: L
        type(function), pointer :: fn
        type(record), pointer :: r
        type(field), pointer :: f, ff
        character (len=2048) :: input=' '
        type(function), pointer :: fn2 ! KP
	logical :: constraint

        nullify(inputfile)
	nullify(functionlist)
	nullify(f)
	nullify(L)
	nullify(idlist)

	nfun = 0

!	Read the entire input file into the inputfile
!	structure:

	call readinputfile

	constraint = .false.
        lineno = 0
        do

!       Retrieve a line until we reach one which is not a comment:
!	L is nullified at end of file.

	  call readline(L, input, lineno)

	  if (.not.associated(L)) exit

!       Read a new function?

          if (input(1:1).eq.'$') then
            nfun = nfun + 1
	    write(*,*)'NFUN=', nfun, ' INPUT=',trim(input)

            if (associated(functionlist)) then
	      call newfunction(fn%next); fn => fn%next
	      fn2 => functionlist   ! KP
            else
	      call newfunction(functionlist); fn => functionlist
            endif
	    constraint = .false.

!	Set a flag here if we are reading variable declarations to avoid
!	pulling the plug if we can't find a colon:

	    if (eqv(input,'$sectors:') .or. eqv(input,'$commodities:') .or. &
		eqv(input,'$consumers:') .or. eqv(input,'$auxiliary:') .or. &
		eqv(input(1:12),'$constraint:') ) then
	      readvars = .true.
	    else
	      readvars = .false.
	    end if
          else
            if (.not.associated(functionlist)) &
              stop 'Error == MPSGE input must begin with a function.'
          end if

!       Read a new record?

	  if (associated(fn%firstrecord)) then
	    call newrecord(r%next);  r => r%next; 
	  else
	    call newrecord(r); fn%firstrecord => r; 
	  end if
	  r%line => L
	  fn%nrecord = fn%nrecord + 1

	  nullify(f)
	  L%record => r

	  if (constraint) cycle

	  constraint = eqv(input(1:12), '$constraint:')

!	Keep pulling fields off the input record until there are no more:

          do while (input.ne.' ')

	    call newfield(ff)

!	This logic only applies to the first field extracted from the
!	line:

	    r%firstfield => ff
	    if (associated(f)) ff%next => f

            f => ff
            f%line => L
            r%nfield = r%nfield + 1
	    fn%nfield = fn%nfield + 1

	    call readfield(input,f)
          end do

        end do
	write(*,*) ' NFUN= ', nfun    ! KP

	return
        end subroutine readmps

!!	Public function determines whether two strings are
!!	identical apart from case.  

        logical function eqv(t1,t2)
	implicit none
        integer :: i
        character (len=*) :: t1,t2
	character (len=255) :: s1,s2
	character (len=26) :: upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', &
			      lower = 'abcdefghijklmnopqrstuvwxyz'

	s1 = t1
	s2 = t2
	if (quoted(t1)) s1 = t1(2:len_trim(t1)-1)
	if (quoted(t2)) s2 = t2(2:len_trim(t2)-1)
	  
	eqv = .false.
	if (len_trim(s1).ne.len_trim(s2)) return
        do i=1,len_trim(s1)
          if (.not. ((s1(i:i).eq.s2(i:i)) .or. &
	      (index(upper,s1(i:i))+index(upper,s2(i:i)).ne.0 .and. &
	       index(upper,s1(i:i)).eq.index(lower,s2(i:i)) .and. &
	       index(upper,s2(i:i)).eq.index(lower,s1(i:i))))) return
	end do
	eqv = .true.
	return
	end function eqv

!!	Read the entire input file structure:

	subroutine readinputfile
	type (line), pointer :: L
        character (len=2048) :: input
	integer :: lineno
	integer :: ic

	nullify(L)
	lineno = 0
	do
          read(iomps,'(a)',end=100) input

	  if (input(1:1).eq.'+') then
	    if (.not.associated(L)) &
	      stop 'Cannot begin MGE file with a continuation line.'
	    if (len_trim(L%text)+len_trim(adjustl(input(2:))).ge.len(L%text)) &
	      stop 'Input line is too long.'
	    L%text = trim(L%text)//' '//trim(adjustl(input(2:)))
	    lineno = lineno + 1
	    cycle
	  endif

	  lineno = lineno + 1

	  if (associated(L)) then
	    call newline(L%next)
	    L => L%next
	  else
	    call newline(inputfile)
	    L => inputfile
	  endif

	  L%text = input
	  L%lineno = lineno
	end do
100	return
	end subroutine readinputfile

!!	Read to the next non-blank line from the input file, incrementing
!!	the line count:

	subroutine readline(L,input,lineno)
	type (line), pointer :: L
        character (len=*) :: input
	integer :: lineno
	integer :: ic

	input = ' '
	do while (input.eq.' ')
	  if (.not.associated(L)) then
	    L => inputfile
	  else
	    if (.not.associated(L%next)) then
	      nullify(L)
	      return
	    end if
	    L => L%next
	  end if
	  write(iogms,'(a,i0,a,t12,a)') '[',L%lineno,']',trim(L%text)

	  input = L%text
	  lineno = L%lineno

	  ic = index(input,'!')
	  if (ic.gt.0) input(ic:) = ' '
	  call tab2blank(input)       ! Convert tabs to blanks:
	  if (input(1:1).eq.'*') input = ' '
	end do

	return
	end subroutine readline

!!	Read the last field from a line of input, using the 
!!	colon to locate the label and the data components:	

	subroutine readfield(input,f)
	type (field), pointer :: f
        character (len=*) :: input
	integer :: ic

	ic = index(input,':',back=.true.)
	if ((.not.readvars) .and. (ic.eq.0)) stop 'No colon?'
	f%data = adjustl(input(ic+1:))
	if (ic.eq.0) then
	  f%label = ' '
	else
	  input(ic:) = ' '
	  ic = index(input(1:ic-1),' ',back=.true.)
	  f%label = input(ic+1:)
	  call lower(f%label)
	end if
	input(ic+1:) = ' '

	return
	end subroutine readfield

!!      Fold a character string to lower case.

        subroutine lower(word)
        IMPLICIT NONE
        character (len=*) :: word  !! Character to be placed in lower case.
        integer :: i
        do 100 i=1,len(word)
          if (word (i:i).eq.'A') word (i:i) = 'a'
          if (word (i:i).eq.'B') word (i:i) = 'b'
          if (word (i:i).eq.'C') word (i:i) = 'c'
          if (word (i:i).eq.'D') word (i:i) = 'd'
          if (word (i:i).eq.'E') word (i:i) = 'e'
          if (word (i:i).eq.'F') word (i:i) = 'f'
          if (word (i:i).eq.'G') word (i:i) = 'g'
          if (word (i:i).eq.'H') word (i:i) = 'h'
          if (word (i:i).eq.'I') word (i:i) = 'i'
          if (word (i:i).eq.'J') word (i:i) = 'j'
          if (word (i:i).eq.'K') word (i:i) = 'k'
          if (word (i:i).eq.'L') word (i:i) = 'l'
          if (word (i:i).eq.'M') word (i:i) = 'm'
          if (word (i:i).eq.'N') word (i:i) = 'n'
          if (word (i:i).eq.'O') word (i:i) = 'o'
          if (word (i:i).eq.'P') word (i:i) = 'p'
          if (word (i:i).eq.'Q') word (i:i) = 'q'
          if (word (i:i).eq.'R') word (i:i) = 'r'
          if (word (i:i).eq.'S') word (i:i) = 's'
          if (word (i:i).eq.'T') word (i:i) = 't'
          if (word (i:i).eq.'U') word (i:i) = 'u'
          if (word (i:i).eq.'V') word (i:i) = 'v'
          if (word (i:i).eq.'W') word (i:i) = 'w'
          if (word (i:i).eq.'X') word (i:i) = 'x'
          if (word (i:i).eq.'Y') word (i:i) = 'y'
          if (word (i:i).eq.'Z') word (i:i) = 'z'
          if (word (i:i).eq.char(9)) word(i:i) = ' '
100     continue
        return
        end subroutine lower

!!      Fold a character string to upper case.

        subroutine upper(word)
        IMPLICIT NONE
        character (len=*) :: word  !! Character to be placed in upper case.
        integer :: i, iacharpos, newpos
	character :: ch1
        do 100 i=1,len(word)
	  ch1 = word(i:i)
	  iacharpos=IACHAR(ch1)
! "a" is ASCII character 97 and "z" is ASCII character 122
! "A" is ASCII character 95 and "z" is ASCII character 90
	  if(iacharpos.ge.97.and.iacharpos.le.122) then
	    newpos = iacharpos - 32
	    word(i:i) = ACHAR(newpos)
	  end if
          if (word (i:i).eq.char(9)) word(i:i) = ' '
100     continue
        return
        end subroutine upper

!!      Convert tabs on an input line to spaces:

        subroutine tab2blank(line)
        character (len=*) :: line  !! Line to scan for tabs
        character :: tab=char(9)
        integer :: k
        do k=1,len_trim(line)
          if (line(k:k).eq.tab) line(k:k) = ' '
        end do
        return
        end subroutine tab2blank

!!      Generate an echoprint of the file.  This is currently very preliminary,
!!      and will later be recoded to produce a more carefully formatted report.

        subroutine echoprint

        type(function), pointer :: fn
        type(record), pointer :: r
        type(field), pointer :: f
	type(domain), pointer :: d
	character (len=255) :: textstr
	integer :: i
 
        fn => functionlist
        nullify(f);
        do while (associated(fn))
          write(*,fmt) ' ===== '
	  r => fn%firstrecord
	  do while (associated(r))
	    f => r%firstfield
	    do while (associated(f))
	      write(*,fmt) ' '//trim(f%label)//':'//trim(f%data)
	      write(*,fmt) ' Identifier text: '//trim(f%identtext)
	      if (len_trim(f%condtext).gt.0) write(*,fmt) ' Condition: '//trim(f%condtext)     
	      if (len_trim(f%spantext).gt.0) write(*,fmt) ' Span: '//trim(f%spantext)
	      if (len_trim(f%argtext).gt.0) write(*,fmt) ' Argument text: '//trim(f%argtext)     
	      d => f%arg
	      call domaintext(d,textstr)
	      if (len_trim(textstr).gt.0) write(*,fmt) ' Argument domain:'//trim(textstr)
	      d => f%cond
	      call domaintext(d,textstr)
	      if (len_trim(textstr).gt.0) write(*,fmt) ' Condition domain:'//trim(textstr)
	      f => f%next
	    end do
	    r => r%next
	  end do
	  fn => fn%next
        end do

	return
	end subroutine echoprint

!!      Parse all fields in the file into constituent elements:
!!      - Field identifier text
!!      - Identifier argument text
!!      - Spanning domain text
!!      - Condition text.

        subroutine parse
	integer :: ic
        type(function), pointer :: fn
        type(record), pointer :: r
        type(field), pointer :: f
        type(symbol), pointer :: s

        fn => functionlist
        nullify(f);
        do while (associated(fn))
	  r => fn%firstrecord
	  do while (associated(r))
	    f => r%firstfield
	    do while (associated(f))

!	Sort out the data:

	      call split(f%data, f%identtext, f%argtext, f%spantext, f%condtext)

!       Read domain for each field --- not needed.

	      if (f%argtext .ne.' ') call readdomain(f%argtext,  f%arg, f%line)
	      if (f%spantext.ne.' ') call readdomain(f%spantext, f%span, f%line)
	      ic = index(f%condtext,'(')
	      if (ic.gt.1) call readdomain(f%condtext(ic:), f%cond, f%line)
	      if (f%identtext.ne.' ') then
		call findid(f%identtext, s)
		f%ident => s
	      end if
	      f => f%next
	    end do
	    r => r%next
	  end do
	  fn => fn%next
	end do
	return
        end subroutine parse

!!      Split up an input field into the constituent elements
!!      - Field identifier text
!!      - Identifier argument text
!!      - Spanning domain text
!!      - Condition text.
!!
!!      For example:
!!>
!!      i:p(i,t)#(s)$beta       
!!<
!!      parses into:
!!>
!!      Field identifier: p
!!      Argument text: i,t
!!      Spanning domain text: s
!!      Condition text: beta
!!<
        subroutine split(field,ident,arg,span,condtext)
        character (len=*), intent(in)  :: field
        character (len=*), intent(out) :: ident,arg,span,condtext
        integer :: ic, np

        ident = ' '
        arg = ' '
        span = ' '
        condtext = ' '

!       Split field text into text fields for the identifier, the argument domain,
!       the span domain and conditional clause:

        np = 0
        ident = field
        do ic=1,len_trim(field)
          if (field(ic:ic).eq.'(') np = np + 1
          if (field(ic:ic).eq.')') np = np - 1
          if (field(ic:ic).eq.'$' .and. np.eq.0) then
            condtext = field(ic+1:)
	    if (ic.gt.1) then
	      ident = field(1:ic-1)
	    else
	      ident = ' '
	    end if
          end if
        end do
        if (np.ne.0) stop ' *** Parethesis mismatch.'

        ic = index(ident,'#')
        if (ic.gt.0) then
          span = adjustl(ident(ic+1:))
          ident(ic:) = ' '
        end if

        ic = index(ident,'(')
        if (ic.gt.1) then
          arg = ident(ic:)
          ident(ic:) = ' '
        end if

	if (splitlog) then
	  write(*,fmt) ' --------------'
	  write(*,fmt) ' field  = '//trim(field)
	  write(*,fmt) ' ident  = '//trim(ident)
	  write(*,fmt) ' arg    = '//trim(arg)
	  write(*,fmt) ' span   = '//trim(span)
	  write(*,fmt) ' condtext = '//trim(condtext)
	end if

        return
        end subroutine split

!! Return pointer to given identifier

        subroutine findid(name, id)             
        character (len=*), intent(in) :: name   !! Identifier for the symbol to be located
        type (symbol), pointer :: id            !! Pointer into the master list for the located symbol.
        type (symbol), pointer :: s

        nullify(id)
        s => idlist
        do while (associated(s))
          if (s%name==name) then
            id => s
            return
          end if
          s => s%next
        end do
        return 
        end subroutine findid

!!	Returns .true. if the argument is quoted text, i.e. a character
!!	string beginning and ending with a pair of single or double quotes.

	logical function quoted(arg)
	character (len=*) :: arg
	integer :: lc
	lc = len_trim(arg)
	quoted = .true.
	if (arg(1:1).eq."'" .and. arg(lc:lc).eq."'") return
	if (arg(1:1).eq.'"' .and. arg(lc:lc).eq.'"') return
	quoted = .false.
	return
	end function quoted


!!	Allocate a new line and assign default values

	subroutine newline(L)
	type (line), pointer :: L
	nullify(L)
	allocate(L)
	nullify(L%next)
	L%lineno = 0
	L%text = ' '
	return
	end subroutine newline

!!	Allocate a new function pointer with default values

	subroutine newfunction(fn)
	type (function), pointer :: fn
	nullify(fn)
	allocate(fn)
	fn%nfield = 0
	fn%nrecord = 0
	nullify(fn%next)
	nullify(fn%inputs)
	nullify(fn%outputs)
        nullify(fn%endowments)
        nullify(fn%demand)
	nullify(fn%firstrecord)
	return
	end subroutine newfunction


!!	Allocate a new domain pointer with default values

	subroutine newdomain(d)
	type (domain), pointer :: d
	nullify(d)
	allocate(d)
	nullify(d%next)
	nullify(d%s)
	d%dim = -1
	return
	end subroutine newdomain

!!	Allocate a new field with default values

	subroutine newfield(f)
	type (field), pointer :: f
	nullify(f)
	allocate(f)
	f%label = ' '
	f%data = ' '
	f%identtext = ' '
	f%argtext = ' '
	f%spantext = ' '
	f%condtext = ' '
	nullify(f%ident)
	nullify(f%arg)
	nullify(f%span)
	nullify(f%cond)
	nullify(f%line)
	nullify(f%next)
	return
	end subroutine newfield

!!	Allocate a new record with default values

	subroutine newrecord(r)
	type (record), pointer :: r
	nullify(r)
	allocate(r)
	nullify(r%firstfield)
	nullify(r%line)
	r%nfield = 0
	nullify(r%next)
	return
	end subroutine newrecord

	logical function singleton(string)
	character (len=*) :: string
	singleton = ((string(1:1).eq.'"') .or. (string(1:1).eq."'"))
	return
	end function singleton

!!	Read a domain and parse into a series of set elements.  

        subroutine readdomain(dtext,d,L)
        character (len=*), intent(in) :: dtext	!! Domain to be parsed
        type (domain), pointer :: d  !! Pointer to the domain list
        type (line), pointer :: L  !! Pointer to source line
        character (len=255) :: textfield
        character (len=31) :: setid
        integer :: ic

        textfield = dtext

!       Check for leading and closing parentheses (required):

        if (len_trim(textfield).le.2) then
          stop ' *** READDOMAIN: invalid domain text.'
        endif

        if (textfield(1:1).ne.'(') then
          stop ' *** READDOMAIN: opening parenthes in domain text is missing.'
        endif

        if (textfield(len_trim(textfield):len_trim(textfield)).ne.')') then
          stop ' *** READDOMAIN: closing parenthesis in domain text is missing.'
        endif

        textfield = adjustl(textfield(2:len_trim(textfield)-1))

!       Check that there are no extra paretheses:

        if (index(textfield,'(') + index(textfield,')')  + &
            index(textfield,';') + index(textfield,':').gt.0) then
          stop ' *** READDOMAIN: embedded parenthesese or semicolons in domain text.'
        endif

        call lower(textfield)
        do while (textfield.ne.' ')
          ic = index(textfield,',')
          if (ic.eq.0) then
            setid = adjustl(textfield)
            textfield = ' '
          else
            if (ic.eq.1) stop ' *** READDOMAIN: empty set specification.'
            setid = adjustl(textfield(1:ic-1))
            textfield = textfield(ic+1:)
          end if
	  if (.not. quoted(setid)) call domainadd(setid, d, L)
        end do

        return
        end subroutine readdomain

!! Add a set element to the domain

        subroutine domainadd(name,dm, L)     
        character (len=*), intent (in) :: name	!! Identier of set to be added to the domain
        type (domain), pointer :: dm  !! Domain to which this set is to be introduced
        type (line), pointer :: L  !! Line in which the set reference was made.

        type (symbol), pointer  :: s
        type (domain), pointer :: d

!       Find what set we are introducing

        call findid(name, s)
        if (associated(s)) then
          if (s%type.ne.'set') stop 'Error -- not a SET'
          call addlineref(L, s)
        else
          call addid(name,'set',s,L)
        end if

        if (.not. associated(dm)) then
	  call newdomain(dm); dm%s => s; 
          return
        endif

!       Add this set at the end of the domain list if it
!	is not already in the domain list:

        d => dm
        do 

!	Set element already is in the domain -- do nothing.

	  if (d%s%name.eq.name) return
          if (.not.associated(d%next)) exit
          d => d%next
        end do
	call newdomain(d%next)
	d=>d%next; d%s => s; 

        return
        end subroutine domainadd


!!	Add an entry in the linked list of line numbers which refer to a given symbol.

        subroutine addlineref(L,s)

        type (symbol), pointer  :: s  !! Symbol which is referenced
        type (line), pointer :: L	!! Line in which the symbol is referenced
        type (linelist), pointer :: LL

        LL => s%lines
        do while (associated(LL))
          if (L%lineno.eq.LL%line%lineno) return
          if (.not. associated(LL%next)) exit
          LL => LL%next
        end do
        allocate(LL%next)
        LL => LL%next
        LL%line => L
        nullify(LL%next)
        return
        end subroutine addlineref

!! Introduce a new identifier in the master list.

        subroutine addid(name, type, s, L)      

!!      Name of the identifier to be added to the master list

        character (len=*), intent(in) :: name

!!      Description of the type of item to be introduced:
!!      - _set_: a GAMS set identifier
!!      - _parameter_ : a GAMS parameter identifier
!!      - _sector_ : an MPSGE sector (acivity variable)
!!      - _commodity_ : an MPSGE commodity (price variable)
!!      - _consumer_ : an MPSGE consumer (income variable)
!!      - _auxiliary_ : an MPSGE auxiliary variable

        character (len=*), intent(in) :: type
        type (symbol), pointer :: s
        type (line), pointer :: L

        if (.not.associated(idlist)) then
	  call newsymbol(idlist)
          s => idlist
        else
	  call newsymbol(idlast%next)
          s => idlast%next
        end if
        s%name = name
        s%type = type
        allocate(s%lines);
        s%lines%line => L
        nullify(s%lines%next)
        nullify(s%next)

! Additions by KP
	nullify(s%arg)  ! KP
	s%labelinfo= ''  ! KP

        idlast => s
        return
        end subroutine addid

!!	Allocate a new symbol and assign default values
!!	for all the symbol characteristics

	subroutine newsymbol(s)
	type (symbol), pointer :: s
	nullify(s)
	allocate(s)
	s%name = ' '
	s%type = 'undefined'
	nullify(s%lines)
	nullify(s%next)
	s%dim = -1
	nullify(s%arg)  ! KP
	s%labelinfo = ' '  ! KP
	return
	end subroutine newsymbol

	subroutine domaintext(dd,textstr)
	type (domain), pointer :: d,dd
	character (len=*) :: textstr
	logical :: first
	textstr = ''
	if (.not.associated(dd)) return
	d => dd
	first = .true.
	do while (associated(d))
	  if (first) then
	    textstr = trim(d%s%name)
	    first = .false.
	  else
	    textstr = trim(textstr)//','//trim(d%s%name)
	  endif
	  d => d%next
	end do
	return
	end subroutine domaintext



end module readmge

